Fritz: All Fritz/All Fritz.zip/All Fritz/FILES/PROGSCAL/INLINE.LZH/UNPARS.INC

Text File | 1986-10-06 | 7KB | 318 lines

                       {
UnPars.inc}
(*********  Source code Copyright 1986, by L. David Baldwin   *********)

type
  symb = (nul,ident4,ident2,identunk,bytesy,wordsy,lparn,rparn);
var
  sy  : symb;

{
-------------DefaultExtension}
PROCEDURE DefaultExtension(extension:filestring;VAR infile,name :filestring);
{Given a filename, infile, add a default extension if none exists. Return
 also the name without any extension.}
var
 I,J : Integer;
 temp : filestring;
begin
I:=Pos('..',infile);
if I=0 then
  temp:=infile
else
  begin   {a pathname starting with ..}
  temp:=Copy(infile,I+2,64);
  I:=I+1;
  end;
J:=Pos('.',temp);
if J=0 then
  begin
  name := infile;
  infile:=infile+'.'+extension;
  end
else name:=Copy(infile,1,I+J-1);
end;

{
-------------Getch}
PROCEDURE Getch;
{Return next char in Uch and lch with Uch in upper case. Ignore comments}
var comment : boolean;
  PROCEDURE GetchBasic; {read a character and a character pair}
  begin
  if chi<=ord(st[0]) then
    begin  {NOTE: pair has the same address as lch}
    move(st[chi], pair, 2);
    if lch=chr(tab) then lch:=' ';
    Uch := upcase(lch);
    chi := chi+1;
    end
  else
    if not eof(inf) then
      begin
      readln(inf,st);
      st:=st+' ';  {EOL is equivalent to space}
      chi:=1;
      Getch;
      end
    else
      begin
      eofinf:=true;
      if comment then
        begin
        writeln('Open Comment at End of Input File');
        halt(1);
        end;
      end;
  end;

begin  {Getch}
if uch<>' ' then
  symname:=symname+uch;  {build up a phrase with old character}
repeat
  if eofinf then
    begin WriteLn('Unexpected End of Input File'); Halt(1) end;
  comment:=false;
  getchbasic;
  if (uch='{') or (pair='(*') then
    begin
    comment:=true;
    if uch='{' then repeat getchbasic; until uch='}'
    else
      begin
      repeat getchbasic; until pair='*)';
      getchbasic;  {pass by the '*'}
      end;
    end;
until not comment;
end;

{
-------------SkipSpaces}
PROCEDURE SkipSpaces;
begin
while (Uch=' ') or (Uch=chr(tab)) do
  Getch;
end;

{
-------------GetDec}
FUNCTION GetDec(var v :integer): boolean ;
const
  ssize = 8;
var
  s        : string[ssize];
  getd     : boolean;
  code     : integer;
begin
getd := false;
s := '';
while (Uch>='0') and (Uch<='9') do
  begin
  getd := true;
  if ord(s[0])<ssize
    then s := s+Uch;
  Getch;
  end;
if getd then
    begin
    val(s,v,code);
    if code<>0
      then error(chi,'Bad Number Format');
    end;
GetDec := getd;
end;

{
-------------GetHex}
FUNCTION GetHex(var h :integer): boolean;
var
  digit   : integer;     {check for '$' before the call}
begin
h := 0;
GetHex := false;
while (Uch in ['A'..'F','0'..'9']) do
  begin
  GetHex := true;
  if (Uch>='A')
    then digit := ord(Uch)-ord('A')+10
    else digit := ord(Uch)-ord('0');
  if h>=$1000
    then error(chi,'Overflow');
  h := (h shl 4)+digit;
  Getch;
  end;
end;

{
-------------GetNumber}
FUNCTION GetNumber(var n :integer): boolean;
{get a number and return it in n}
begin
skipspaces;
n := 0;
if Uch='$'
  then
    begin        {a hex number}
    Getch;
    if not GetHex(n)
      then error(chi, 'Hex Number Exp');
    GetNumber := true;
    end
  else
    begin        {maybe a decimal number}
    GetNumber := getdec(n);
    end;
end;

{
-------------GetExpr}
FUNCTION GetExpr(var rslt :integer): boolean;
var
  rs1,rs2 : integer;
  pos,neg,GE : boolean;
begin
GE := false;
SkipSpaces;
neg := Uch='-';
pos := Uch='+';
if pos or neg
  then Getch;
if GetNumber(rs1)
  then
    begin
    GE := true;
    if neg
      then rs1 := -rs1;
    skipspaces;
    if (Uch='+') or (Uch='-') then
      if GetExpr(rs2) then
        rs1 := rs1+rs2      {GetExpr will take care of sign}
      else GE:=false;
    rslt := rs1;
    end;
skipspaces;
GetExpr:=GE and ((uch='/') or (uch=')'));  {must terminate in '/' or ')'}
end;

{
-------------Gettoken}
PROCEDURE Gettoken;
const
  tokenchars : set of char = ['A'..'Z','0'..'9','_'];
  startchars : set of char = ['A'..'Z','_'];
begin
while not (Uch in startchars) and not eofinf do getch;
token[0] := #0;
if not eofinf then
    while Uch in tokenchars do
      begin
      if ord(token[0])<tokenleng
        then token := token+Uch;
      Getch;
      end;
end;

{
-------------next}
PROCEDURE next;
var c : char;

  FUNCTION GetExprX(var N : integer; var C : char): boolean;
  begin
  C:=Uch;
  if (uch='>') or (uch='<') then getch;
  GetExprX:=GetExpr(N);
  end;

begin
sy := nul;
Repeat
  SkipSpaces;
  symname[0]:=#0;     {build up a phrase which may be needed later}
  if bytepending then
    begin
    nvalue:=pendingbyte;
    bytepending:=false;
    sy:=bytesy;
    end
  else if uch='(' then begin sy:=lparn; getch; end
  else if uch=')' then begin sy:=rparn; getch; end
  else if uch='/' then error(chi+2, 'Syntax')
  else if GetExprX(nvalue,c) then
    begin
    if c='<' then sy:=bytesy
      else if c='>' then sy:=wordsy
      else if nvalue and $ff00 = 0 then sy := bytesy
      else sy:=wordsy;
    if uch='/' then getch;
    end
  else
    begin  {it's a symbolic phrase}
    while (uch<>'/') and (uch<>')') do getch;  {finish reading the phrase}
    if uch='/' then
      begin
      getch;  {pass the '/' by}
      symname[0]:=pred(symname[0]); {but remove it from phrase}
      end;
    if (pos('>',symname)>0) or (pos('*',symname)>0) then
      sy:=ident4
    else if pos('<',symname)>0 then sy:=ident2
    else sy:=identunk;    {unknown size}
    end;
  if sy=nul then getch;
until sy<>nul;
end;

{
-------------getbyte}
FUNCTION getbyte(var p :packet; phraseok : boolean): boolean;
var result : boolean;
begin
result:=true;
with p do
  begin
  dispsize:=bytesize;  phrase:=false;
  if (sy=ident2) or (sy=identunk) then
    begin
    if not phraseok then result:=false
    else
      begin
      phrase:=true;
      if sy=identunk then insert('<',symname,1);
      s:=symname;  {the phrase}
      end;
    end
  else if sy=bytesy then value:=lo(nvalue)
  else if sy=wordsy then
    begin
    value:=lo(nvalue);
    bytepending:=true;
    pendingbyte:=Hi(nvalue);
    end
  else result:=false;
  if result then
    begin
    PC:=PC+1;
    next;
    end;
  getbyte:=result;
  end;
end;

{
-------------getword}
PROCEDURE getword(var p :packet);
var H,L : packet;
  PROCEDURE WordErr;
  begin error(chi,'Word or two bytes exp'); PC:=PC+2; next; end;
begin
with p do
  begin
  dispsize:=wordsize; phrase:=false;
  if (sy=ident4) or (sy=identunk) then
    begin
    if sy=identunk then insert('>',symname,1);
    phrase:=true; s:=symname;
    PC:=PC+2;  next;
    end
  else if sy=ident2 then worderr
  else if sy=wordsy then
    begin value:=nvalue; PC:=PC+2;  next; end
  else if getbyte(L,not PhraseOk) then
    begin
    if not getbyte(H, not PhraseOk) then numbyteerr;
    value:=H.value shl 8 +L.value;
    end
  else WordErr;
  end;
end;